home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
clx.lha
/
clx
/
translate.l
< prev
Wrap
Lisp/Scheme
|
1988-09-12
|
26KB
|
626 lines
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package 'xlib :use '(lisp))
(export '(define-keysym-set
keysym-set
define-keysym
undefine-keysym
default-keysym-translate
keysym
character->keysyms
keycode->keysym
keysym->character
default-keysym-index
keycode->character
state-keysym-p
mapping-notify
keysym-in-map-p
character-in-map-p
keysym->keycodes
))
(defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
(defun define-keysym-set (set first-keysym last-keysym)
;; Define all keysyms from first-keysym up to and including
;; last-keysym to be in SET (returned from the keysym-set function).
;; Signals an error if the keysym range overlaps an existing set.
(declare (type keyword set)
(type keysym first-keysym last-keysym))
(when (> first-keysym last-keysym)
(rotatef first-keysym last-keysym))
(setq *keysym-sets* (delete set *keysym-sets* :key #'car))
(dolist (set *keysym-sets*)
(let ((first (second set))
(last (third set)))
(when (or (<= first first-keysym last)
(<= first last-keysym last))
(error "Keysym range overlaps existing set ~s" set))))
(push (list set first-keysym last-keysym) *keysym-sets*)
set)
(defun keysym-set (keysym)
;; Return the character code set name of keysym
(declare (type keysym keysym)
(values keyword))
(dolist (set *keysym-sets*)
(let ((first (second set))
(last (third set)))
(when (<= first keysym last)
(return (first set))))))
(eval-when (compile eval load) ;; Required for Vaxlisp ...
(defmacro keysym (keysym &rest bytes)
;; Build a keysym.
;; If KEYSYM is an integer, it is used as the most significant bits of
;; the keysym, and BYTES are used to specify low order bytes. The last
;; parameter is always byte4 of the keysym. If KEYSYM is not an
;; integer, the keysym associated with KEYSYM is returned.
;;
;; This is a macro and not a function macro to promote compile-time
;; lookup. All arguments are evaluated.
(declare (type t keysym)
(type list bytes)
(values keysym))
(typecase keysym
((integer 0)
(dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
(otherwise
(or (car (character->keysyms keysym))
(error "~s Isn't the name of a keysym" keysym)))))
)
(defvar *keysym->character-map* (make-hash-table :test #'eq :size 400))
;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
;; With the following accessor macros. Everything after OBJECT is optional.
(eval-when (eval compile) ;; Not needed at run-time
(defmacro keysym-mapping-object (keysym-mapping)
;; Parameter to translate
`(first ,keysym-mapping))
(defmacro keysym-mapping-translate (keysym-mapping)
;; Function to be called with parameters (display state OBJECT)
;; when translating KEYSYM and modifiers and mask are satisfied.
`(second ,keysym-mapping))
(defmacro keysym-mapping-lowercase (keysym-mapping)
;; LOWERCASE is used for uppercase alphabetic keysyms. The value
;; is the associated lowercase keysym.
`(third ,keysym-mapping))
(defmacro keysym-mapping-modifiers (keysym-mapping)
;; MODIFIERS is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying when to use this
;; keysym-translation.
`(fourth ,keysym-mapping))
(defmacro keysym-mapping-mask (keysym-mapping)
;; MASK is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying which modifiers to look at
;; (i.e. modifiers not specified are don't-cares)
`(fifth ,keysym-mapping))
) ;; end eval-when
(defvar *default-keysym-translate-mask*
(the (or (member :modifiers) mask16 list) ; (list (or keysym state-mask-key))
(logand #xff (lognot (make-state-mask :lock))))
"Default keysym state mask to use during keysym-translation.")
(defun define-keysym (object keysym &key lowercase translate modifiers mask display)
;; Define the translation from keysym/modifiers to a (usually
;; character) object. ANy previous keysym definition with
;; KEYSYM and MODIFIERS is deleted before adding the new definition.
;;
;; MODIFIERS is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying when to use this
;; keysym-translation. The default is NIL.
;;
;; MASK is either a modifier-mask or list containing intermixed
;; keysyms and state-mask-keys specifying which modifiers to look at
;; (i.e. modifiers not specified are don't-cares).
;; If mask is :MODIFIERS then the mask is the same as the modifiers
;; (i.e. modifiers not specified by modifiers are don't cares)
;; The default mask is *default-keysym-translate-mask*
;;
;; If DISPLAY is specified, the translation will be local to DISPLAY,
;; otherwise it will be the default translation for all displays.
;;
;; LOWERCASE is used for uppercase alphabetic keysyms. The value
;; is the associated lowercase keysym. This information is used
;; by the keysym-both-case-p predicate (for caps-lock computations)
;; and by the keysym-downcase function.
;;
;; TRANSLATE will be called with parameters (display state OBJECT)
;; when translating KEYSYM and modifiers and mask are satisfied.
;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
;; (or modifiers 0)))
;; when mask and modifiers aren't lists of keysyms]
;; The default is #'default-keysym-translate
;;
(declare (type (or string-char t) object)
(type keysym keysym)
(type (or null mask16 list) ;; (list (or keysym state-mask-key))
modifiers)
(type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key))
mask)
(type (or null display) display)
(type (or null keysym) lowercase)
(type (function (display card16 t) t) translate))
(flet ((merge-keysym-mappings (new old)
;; Merge new keysym-mapping with list of old mappings.
;; Ensure that the mapping with no modifiers or mask comes first.
(let* ((key (keysym-mapping-modifiers new))
(merge (delete key old :key #'cadddr :test #'equal)))
(if key
(nconc merge (list new))
(cons new merge))))
(mask-check (mask)
(unless (or (numberp mask)
(dolist (element mask t)
(unless (or (find element *state-mask-vector*)
(gethash element *keysym->character-map*))
(return nil))))
(x-type-error mask '(or mask16 (list (or modifier-key modifier-keysym)))))))
(let ((entry
;; Create with a single LIST call, to ensure cdr-coding
(cond
(mask
(unless (eq mask :modifiers)
(mask-check mask))
(when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
(error "Mask with no modifiers"))
(list object translate lowercase modifiers mask))
(modifiers (mask-check modifiers)
(list object translate lowercase modifiers))
(lowercase (list object translate lowercase))
(translate (list object translate))
(t (list object)))))
(if display
(let ((previous (assoc keysym (display-keysym-translation display))))
(if previous
(setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
(push (list keysym entry) (display-keysym-translation display))))
(setf (gethash keysym *keysym->character-map*)
(merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
object))
(defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)
;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
(declare (type (or string-char t) object)
(type keysym keysym)
(type (or null mask16 list) ;; (list (or keysym state-mask-key))
modifiers)
(type (or null display) display))
(flet ((match (key entry)
(let ((object (car key))
(modifiers (cdr key)))
(or (eql object (keysym-mapping-object entry))
(equal modifiers (keysym-mapping-modifiers entry))))))
(let* (entry
(previous (if display
(cdr (setq entry (assoc keysym (display-keysym-translation display))))
(gethash keysym *keysym->character-map*)))
(key (cons object modifiers)))
(when (and previous (find key previous :test #'match))
(setq previous (delete key previous :test #'match))
(if display
(setf (cdr entry) previous)
(setf (gethash keysym *keysym->character-map*) previous))))))
(defun keysym-downcase (keysym)
;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
(declare (type keysym keysym))
(declare-values keysym)
(let ((translations (gethash keysym *keysym->character-map*)))
(or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
(defun keysym-uppercase-alphabetic-p (keysym)
;; Returns T if keysym is uppercase-alphabetic.
;; I.E. If it has a lowercase equivalent.
(declare (type keysym keysym))
(declare-values (or null keysym))
(let ((translations (gethash keysym *keysym->character-map*)))
(and translations
(keysym-mapping-lowercase (first translations)))))
(defun character->keysyms (character &optional display)
;; Given a character, return a list of all matching keysyms.
;; If DISPLAY is given, translations specific to DISPLAY are used,
;; otherwise only global translations are used.
;; Implementation dependent function.
;; May be slow [i.e. do a linear search over all known keysyms]
(declare (type t character)
(type (or null display) display)
(values (list keysym)))
(let ((result nil))
(when display
(dolist (mapping (display-keysym-translation display))
(when (eql character (second mapping))
(push (first mapping) result))))
(maphash #'(lambda (keysym mappings)
(dolist (mapping mappings)
(when (eql (keysym-mapping-object mapping) character)
(pushnew keysym result))))
*keysym->character-map*)
result))
(eval-when (compile eval load) ;; Required for Symbolics...
(defconstant character-set-switch-keysym (keysym 255 126))
(defconstant left-shift-keysym (keysym 255 225))
(defconstant right-shift-keysym (keysym 255 226))
(defconstant left-control-keysym (keysym 255 227))
(defconstant right-control-keysym (keysym 255 228))
(defconstant caps-lock-keysym (keysym 255 229))
(defconstant shift-lock-keysym (keysym 255 230))
(defconstant left-meta-keysym (keysym 255 231))
(defconstant right-meta-keysym (keysym 255 232))
(defconstant left-alt-keysym (keysym 255 233))
(defconstant right-alt-keysym (keysym 255 234))
(defconstant left-super-keysym (keysym 255 235))
(defconstant right-super-keysym (keysym 255 236))
(defconstant left-hyper-keysym (keysym 255 237))
(defconstant right-hyper-keysym (keysym 255 238))
) ;; end eval-when
;;-----------------------------------------------------------------------------
;; Keysym mapping functions
(defun display-keyboard-mapping (display)
(declare (type display display))
(declare-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))
(or (display-keysym-mapping display)
(setf (display-keysym-mapping display) (xlib:keyboard-mapping display))))
(defun keycode->keysym (display keycode keysym-index)
(declare (type display display)
(type card8 keycode)
(type (or null card8) keysym-index)
(values keysym))
(let* ((mapping (display-keyboard-mapping display))
(keysym (aref mapping keycode keysym-index)))
(declare (type (simple-array keysym (* *)) mapping)
(type keysym keysym))
;; The keysym-mapping is brain dammaged.
;; Mappings for both-case alphabetic characters have the
;; entry for keysym-index zero set to the uppercase keysym
;; (this is normally where the lowercase keysym goes), and the
;; entry for keysym-index one is zero.
(cond ((zerop keysym-index) ; Lowercase alphabetic keysyms
(keysym-downcase keysym))
((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
(aref mapping keycode 0))
(t keysym))))
(defun keysym->character (display keysym &optional (state 0))
;; Find the character associated with a keysym.
;; STATE is used for adding char-bits to character as follows:
;; control -> char-control-bit
;; mod-1 -> char-meta-bit
;; mod-2 -> char-super-bit
;; mod-3 -> char-hyper-bit
;; Implementation dependent function.
(declare (type display display)
(type keysym keysym)
(type card16 state))
(declare-values (or null character))
(let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
static-mappings
(mapping (or ;; Find the matching display mapping
(dolist (mapping display-mappings)
(when (mapping-matches-p display state mapping)
(return mapping)))
;; Find the matching static mapping
(dolist (mapping (setq static-mappings (gethash keysym *keysym->character-map*)))
(when (mapping-matches-p display state mapping)
(return mapping))))))
(when mapping
(funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
display state (keysym-mapping-object mapping)))))
(defun mapping-matches-p (display state mapping)
;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
(declare (type display display)
(type mask16 state)
(type list mapping))
(declare-values boolean)
(flet
((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
;; otherwise ignore unknown modifiers.
(declare (type list display-mapping) ; Alist of (keysym . mask)
(type (or mask16 list) modifiers)
(type mask16 mask))
(declare-values (or null mask16))
(if (numberp modifiers)
modifiers
(dolist (modifier modifiers mask)
(declare (type symbol modifier))
(let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
(setq mask
(logior mask
(if bit
(ash 1 bit)
(or (cdr (assoc modifier display-mapping))
;; bad modifier
(if errorp
(return-from modifiers->mask nil)
0))))))))))
(let* ((display-mapping (get-display-modifier-mapping display))
(mapping-modifiers (keysym-mapping-modifiers mapping))
(modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
(return-from mapping-matches-p nil)))
(mapping-mask (or (keysym-mapping-mask mapping) ; If no mask, use the default.
(if mapping-modifiers ; If no modifiers, match anything.
*default-keysym-translate-mask*
0)))
(mask (if (eq mapping-mask :modifiers)
modifiers
(modifiers->mask display-mapping mapping-mask nil))))
(declare (type mask16 modifiers mask))
(= (logand state mask) modifiers))))
(defun default-keysym-translate (display state object)
;; If object is a character, char-bits are set from state.
;;
;; [the following isn't implemented (should it be?)]
;; If object is a list, it is an alist with entries:
;; (string-char [modifiers] [mask-modifiers])
;; When MODIFIERS are specified, this character translation
;; will only take effect when the specified modifiers are pressed.
;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
;; In ambiguous cases, the most specific translation is used.
(declare (type display display)
(type card16 state)
(type t object))
(declare-values t) ;; Object returned by keycode->character
(macrolet ((keystate-p (state keyword)
`(the boolean
(logbitp ,(position keyword *state-mask-vector*)
,state))))
(when (characterp object)
(when (keystate-p state :control)
(setf (char-bit object :control) 1))
(when (state-keysymp display state left-meta-keysym)
(setf (char-bit object :meta) 1))
(when (state-keysymp display state left-super-keysym)
(setf (char-bit object :super) 1))
(when (state-keysymp display state left-hyper-keysym)
(setf (char-bit object :hyper) 1))))
object)
(defun default-keysym-index (display keycode state)
;; Returns a keysym-index for use with keycode->character
(declare-values card8)
(macrolet ((keystate-p (state keyword)
`(the boolean
(logbitp ,(position keyword *state-mask-vector*)
,state))))
(let* ((mapping (display-keyboard-mapping display))
(keysyms-per-keycode (array-dimension mapping 1))
(symbolp (and (> keysyms-per-keycode 2)
(state-keysymp display state character-set-switch-keysym)))
(result (if symbolp 2 0)))
(declare (type (simple-array keysym (* *)) mapping)
(type boolean symbolp)
(type card8 keysyms-per-keycode result))
(when (and (< result keysyms-per-keycode)
(keysym-shift-p display state (keysym-uppercase-alphabetic-p
(aref mapping keycode 0))))
(incf result))
result)))
(defun keysym-shift-p (display state uppercase-alphabetic-p &key
shift-lock-xors
(control-modifiers
'#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
(declare (type display display)
(type card16 state)
(type boolean uppercase-alphabetic-p)
(type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
;;; as neither if the character is alphabetic.
(declare-values boolean)
(macrolet ((keystate-p (state keyword)
`(the boolean
(logbitp ,(position keyword *state-mask-vector*)
,state))))
(let* ((controlp (or (keystate-p state :control)
(dolist (modifier control-modifiers)
(when (state-keysymp display state modifier)
(return t)))))
(shiftp (keystate-p state :shift))
(lockp (keystate-p state :lock))
(alphap (or uppercase-alphabetic-p
(not (state-keysymp display #.(make-state-mask :lock)
caps-lock-keysym)))))
(declare (type boolean controlp shiftp lockp alphap))
;; Control keys aren't affected by lock
(if controlp
;; An alphabetic control character defaults to uppercase
(when alphap (setq shiftp (not shiftp)))
;; Not a control character - check state of lock modifier
(when (and lockp
alphap
(or (not shiftp) shift-lock-xors)) ; Lock doesn't unshift unless shift-lock-xors
(setq shiftp (not shiftp))))
shiftp)))
;;; default-keysym-index implements the following tables:
;;;
;;; control shift caps-lock character character
;;; 0 0 0 #\a #\8
;;; 0 0 1 #\A #\8
;;; 0 1 0 #\A #\*
;;; 0 1 1 #\A #\*
;;; 1 0 0 #\control-A #\control-8
;;; 1 0 1 #\control-A #\control-8
;;; 1 1 0 #\control-shift-a #\control-*
;;; 1 1 1 #\control-shift-a #\control-*
;;;
;;; control shift shift-lock character character
;;; 0 0 0 #\a #\8
;;; 0 0 1 #\A #\*
;;; 0 1 0 #\A #\*
;;; 0 1 1 #\A #\8
;;; 1 0 0 #\control-A #\control-8
;;; 1 0 1 #\control-A #\control-*
;;; 1 1 0 #\control-shift-a #\control-*
;;; 1 1 1 #\control-shift-a #\control-8
(defun keycode->character (display keycode state &key keysym-index
(keysym-index-function #'default-keysym-index))
;; keysym-index defaults to the result of keysym-index-function which
;; is called with the following parameters:
;; (char0 state caps-lock-p keysyms-per-keycode)
;; where char0 is the "character" object associated with keysym-index 0 and
;; caps-lock-p is non-nil when the keysym associated with the lock
;; modifier is for caps-lock.
;; STATE is also used for setting char-bits:
;; control -> char-control-bit
;; mod-1 -> char-meta-bit
;; mod-2 -> char-super-bit
;; mod-3 -> char-hyper-bit
;; Implementation dependent function.
(declare (type display display)
(type card8 code)
(type card16 state)
(type (or null card8) keysym-index)
(type (or null (function (string-char card16 boolean card8) card8))
keysym-index-function))
(declare-values (or null character))
(let* ((index (or keysym-index
(funcall keysym-index-function display keycode state)))
(keysym (if index (keycode->keysym display keycode index) 0)))
(declare (type (or null card8) index)
(type keysym keysym))
(when (plusp keysym)
(keysym->character display keysym state))))
(defun get-display-modifier-mapping (display)
(labels ((keysym-replace (display modifiers mask &aux result)
(dolist (modifier modifiers result)
(push (cons (keycode->keysym display modifier 0) mask) result))))
(or (display-modifier-mapping display)
(multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
(modifier-mapping display)
(setf (display-modifier-mapping display)
(nconc (keysym-replace display shift #.(make-state-mask :shift))
(keysym-replace display lock #.(make-state-mask :lock))
(keysym-replace display control #.(make-state-mask :control))
(keysym-replace display mod1 #.(make-state-mask :mod-1))
(keysym-replace display mod2 #.(make-state-mask :mod-2))
(keysym-replace display mod3 #.(make-state-mask :mod-3))
(keysym-replace display mod4 #.(make-state-mask :mod-4))
(keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
(defun state-keysymp (display state keysym)
;; Returns T when a modifier key associated with KEYSYM is on in STATE
(declare (type display display)
(type card16 state)
(type keysym keysym))
(declare-values boolean)
(let* ((mapping (get-display-modifier-mapping display))
(mask (assoc keysym mapping)))
(and mask (plusp (logand state (cdr mask))))))
(defun mapping-notify (display request start count)
;; Called on a mapping-notify event to update
;; the keyboard-mapping cache in DISPLAY
(declare (type display display)
(type (member :modifier :keyboard :pointer) request)
(type card8 start count)
(ignore count start))
;; Invalidate the keyboard mapping to force the next key translation to get it
(case request
(:modifier
(setf (display-modifier-mapping display) nil))
(:keyboard
(setf (display-keysym-mapping display) nil))))
(defun keysym-in-map-p (display keysym keymap)
;; Returns T if keysym is found in keymap
(declare (type display display)
(type keysym keysym)
(type (bit-vector 256) keymap))
(declare-values boolean)
;; The keysym may appear in the keymap more than once,
;; So we have to search the entire keysym map.
(do* ((min (display-min-keycode display))
(max (display-max-keycode display))
(map (display-keyboard-mapping display))
(jmax (min 2 (array-dimension map 1)))
(i min (1+ i)))
((> i max))
(declare (type card8 min max jmax)
(type (simple-array keysym (* *)) map))
(when (and (plusp (aref keymap i))
(dotimes (j jmax)
(when (= keysym (aref map i j)) (return t))))
(return t))))
(defun character-in-map-p (display character keymap)
;; Implementation dependent function.
;; Returns T if character is found in keymap
(declare (type display display)
(type character character)
(type (bit-vector 256) keymap))
(declare-values boolean)
;; Check all one bits in keymap
(do* ((min (display-min-keycode display))
(max (display-max-keycode display))
(jmax (array-dimension (display-keyboard-mapping display) 1))
(i min (1+ i)))
((> i max))
(declare (type card8 min max jmax))
(when (and (plusp (aref keymap i))
;; Match when character is in mapping for this keycode
(dotimes (j jmax)
(when (eql character (keycode->character display i 0 :keysym-index j))
(return t))))
(return t))))
(defun keysym->keycodes (display keysym)
;; Return keycodes for keysym, as multiple values
(declare (type display display)
(type keysym keysym))
(declare-values (or null keycode) (or null keycode) (or null keycode))
;; The keysym may appear in the keymap more than once,
;; So we have to search the entire keysym map.
(do* ((min (display-min-keycode display))
(max (display-max-keycode display))
(map (display-keyboard-mapping display))
(jmax (min 2 (array-dimension map 1)))
(i min (1+ i))
(result nil))
((> i max) (values-list result))
(declare (type card8 min max jmax)
(type (simple-array keysym (* *)) map))
(dotimes (j jmax)
(when (= keysym (aref map i j))
(push i result)))))